home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / PBTBOX.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  8KB  |  267 lines
  1. {SECTION ..PbTBOX }
  2. UNIT PbTBOX;
  3.  
  4. INTERFACE
  5.  
  6. uses PbMISC;
  7.  
  8. {
  9. Description : Text Line Drawing support
  10.  
  11. Author      : Howard Richoux
  12. Date        : 1/16/91
  13. Last revised: 1/12/94 some cleanup, still not sure what I wrote
  14.               2/18/94 new libraries
  15. Application : IBM PC and compatibles, done in Turbo Pascal 5.5
  16. Status      : Placed in the Public Domain by HNR Software 1/29/1994
  17. Published in: none
  18. }
  19.  
  20. var TBOXType  : byte;   { 0 = off, 1 = single,     2 = double
  21.                                    3 = SL noblank, 4 = DL w/blank
  22.                                    default =  3 }
  23.     TBOXchar  : char;   { triggering character             def. '~'  }
  24.  
  25. Procedure TBOXConvertLine(var line : string);
  26.            {[STRING] Replaces ~ codes with line draw characters}
  27.  
  28. Procedure TBOXSetChars(i : byte; var lch,mch,rch : char);
  29.            {[STRING] Internal, defines some of the codes}
  30.  
  31. Function  TBOXMakeBar(loff,len : byte;  lch,mch,rch : char) : string;
  32.            {[STRING] makes a line draw string  ?? }
  33.  
  34. Function  TBOXMakeBarN(loff,len : byte;  chrset : byte) : string;
  35.            {[STRING] makes a line draw string  ?? }
  36.  
  37. Function  TBOXMergeStrings(st1,st2 : string; l : byte) : string;
  38.            {[STRING] combines st1 & st2, only where st1 is blank }
  39.  
  40. {SECTION .zImplementation }
  41. IMPLEMENTATION
  42.  
  43. {
  44. This is a VERY VERY simple unit to add some IBM graphic character
  45.     Box drawing to an otherwise normal text file.
  46.  
  47.     The graphics are bracketed by '~' (which optionally get
  48.     translated into blanks).
  49.  
  50.     see the example TBOXTEST for specifics.    Here is a partial example.
  51.  
  52.                        This is a Box
  53.  
  54. Everything         ~L---------M-------R~     Mnemonics:
  55. outside            ~|         |       |~     L = Upper Left
  56. the                ~|         |       |~     M = Upper Middle
  57. squiggles          ~|         |       |~     R = Upper Right
  58. is normal          ~S---------+-------s~     S = Left Side
  59. text.              ~|         |       |~     + = center
  60.                    ~|         |       |~     s = right side
  61.                    ~|         |       |~     l = lower left
  62.                    ~l---------m-------r~     m = lover middle
  63.                                              r = lower right
  64.                    ~1222222222222222223~
  65.  
  66. }
  67.  
  68.  
  69.  
  70.  
  71.  
  72. Function SLCvtChar( ch : char) : char;
  73. var c : char;
  74.      begin
  75.      c := ' ';
  76.      case ch of
  77.          '-'         : c := chr(196);
  78.          '|'         : c := chr(179);
  79.          'L'         : c := chr(218);
  80.          'M'         : c := chr(194);
  81.          'R'         : c := chr(191);
  82.          'S'         : c := chr(195);
  83.          's'         : c := chr(180);
  84.          'l'         : c := chr(192);
  85.          'm'         : c := chr(193);
  86.          'r'         : c := chr(217);
  87.          'C','+','c' : c := chr(197);
  88.          '1'         : c := chr(198);
  89.          '2'         : c := chr(205);
  90.          '3'         : c := chr(181);
  91.           end;
  92.      SLCvtChar := c;
  93.      end;
  94.  
  95.  
  96. Function DLCvtChar( ch : char) : char;
  97. var c : char;
  98.      begin
  99.      c := ' ';
  100.      case ch of
  101.          '-'         : c := chr(205);
  102.          '|'         : c := chr(186);
  103.          'L'         : c := chr(201);
  104.          'M'         : c := chr(203);
  105.          'R'         : c := chr(187);
  106.          'S'         : c := chr(204);
  107.          's'         : c := chr(185);
  108.          'l'         : c := chr(200);
  109.          'm'         : c := chr(202);
  110.          'r'         : c := chr(188);
  111.          'C','+','c' : c := chr(206);
  112.          '1'         : c := chr(195);
  113.          '2'         : c := chr(196);
  114.          '3'         : c := chr(180);
  115.           end;
  116.      DLCvtChar := c;
  117.      end;
  118.  
  119.  
  120. {SECTION  TBOXConvertLine }
  121. Procedure TBOXConvertLine(var line : string);
  122. var i,j : integer;
  123.     s   : string;
  124.     linemode : boolean;
  125.      begin
  126.      if (TBOXType < 1) then exit;
  127.      s := '';
  128.      linemode := false;
  129.      if length(line) > 0 then
  130.           begin
  131.           for i := 1 to length(line) do
  132.                begin
  133.                if not linemode and (line[i] = '~') then
  134.                     begin
  135.                     linemode := true;
  136.                     if (TBOXType > 2) then s := s + ' ';
  137.                     end
  138.                else if linemode and (line[i] = '~') then
  139.                     begin
  140.                     linemode := false;
  141.                     if (TBOXType > 2) then s := s + ' ';
  142.                     end
  143.                else if linemode then
  144.                     begin
  145.                     if odd(TBOXType)then
  146.                          s := s + SLCvtChar(line[i])
  147.                     else s := s + DLCvtChar(line[i]);
  148.                     end
  149.                else s := s + line[i];
  150.                end;
  151.           end;
  152.      line := s;
  153.      end;
  154.  
  155.  
  156.  
  157. {SECTION  TBOXSetChars }
  158. Procedure TBOXSetChars(i : byte; var lch,mch,rch : char);
  159.      begin
  160.      case i of
  161.          0  : begin  { single bar flat, no end posts}
  162.               lch := chr(196); mch := chr(196); rch := chr(196);
  163.               end;
  164.          1  : begin  { single bars with blanks between }
  165.               lch := chr(179); mch := chr( 32); rch := chr(179);
  166.               end;
  167.          2  : begin  { single bars with single bar between }
  168.               lch := chr(195); mch := chr(196); rch := chr(180);
  169.               end;
  170.          3  : begin  { single bars with double bar between }
  171.               lch := chr(198); mch := chr(205); rch := chr(181);
  172.               end;
  173.          4  : begin  { top of single line box }
  174.               lch := chr(218); mch := chr(196); rch := chr(191);
  175.               end;
  176.          5  : begin  { bottom of single line box }
  177.               lch := chr(192); mch := chr(196); rch := chr(217);
  178.               end;
  179.  
  180.          { DOUBLE bar things }
  181.  
  182.          32 : begin  { double bar flat, no end posts}
  183.               lch := chr(205); mch := chr(205); rch := chr(205);
  184.               end;
  185.          33  : begin  {double bars with blanks between }
  186.               lch := chr(186); mch := chr( 32); rch := chr(186);
  187.               end;
  188.          34  : begin  {double bars with double bar between }
  189.               lch := chr(204); mch := chr(205); rch := chr(185);
  190.               end;
  191.  
  192.          else begin
  193.               lch := chr(195); mch := chr( 40); rch := chr(195);
  194.               end;
  195.          end;
  196.      end;
  197.  
  198.  
  199. {SECTION  TBOXMakeBar }
  200. Function  TBOXMakeBar(loff,len : byte;  lch,mch,rch : char) : string;
  201. var s,s1,s2 : string;
  202.     l    : byte;
  203.      begin
  204.      s := ''; s1 := ''; s2 := '';
  205.      l := loff + len;
  206.      if l > 0 then
  207.           begin
  208.           s1 := ConstStr(' ',l);
  209.           s2 := ConstStr(mch,len);
  210.          { writeln('s2 1[',s2,']'); }
  211.           if len > 0 then
  212.                begin
  213.                s2[len] := rch;
  214.                s2[1] := lch;
  215.                end;
  216.          { writeln('s2 2[',s2,']'); }
  217.           if loff > 0 then Replacestr(s1,loff+1,s2)
  218.           else s1 := s2;
  219.           s := leftstr(s1,l);
  220.           end;
  221.      TBOXMakeBar := s;
  222.      end;
  223.  
  224.  
  225. {SECTION  TBOXMakeBarN }
  226. Function  TBOXMakeBarN(loff,len : byte;  chrset : byte) : string;
  227. var ch1,ch2,ch3 : char;
  228.      begin
  229.      TBOXSetchars(chrset,ch1,ch2,ch3);
  230.      TBOXMakeBarN := TBOXMakeBar(loff,len,ch1,ch2,ch3);
  231.      end;
  232.  
  233.  
  234. {SECTION  TBOXMergeStrings  }
  235. Function  TBOXMergeStrings(st1,st2 : string; l : byte) : string;
  236. { ST1 takes precedence, need to add more merge logic to join bars }
  237. var s : string;
  238.     i,l1,l2 : byte;
  239.     c1,c2 : char;
  240.      begin
  241.      s := '';
  242.      if l > 0 then
  243.           begin
  244.           l1 := length(st1);
  245.           l2 := length(st2);
  246.           for i := 1 to l do
  247.                begin
  248.                c1 := ' '; c2 := ' ';
  249.                if i <= l1 then c1 := st1[i];
  250.                if i <= l2 then c2 := st2[i];
  251.                if      (c1 <> ' ') then s := s + c1
  252.                else if (c2 <> ' ') then s := s + c2
  253.                else s := s + ' ';
  254.                end;
  255.           s := leftstr(s,l);
  256.           end;
  257.      TBOXMergeStrings := s;
  258.      end;
  259.  
  260.  
  261. {SECTION  zzInitialization }
  262.      begin {initialization}
  263.      TBOXType := 3;   { SL no blank }
  264.      TBOXchar     := '~';
  265.      end.
  266.  
  267.